home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / table_util.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  3.7 KB  |  108 lines
  1. (herald table_util
  2.   (env tsys))
  3.  
  4. ;;;                      UTILITIES
  5. ;;;============================================================================
  6.  
  7. ;;; Do (PROC <key> <value>) for every (<key> <value>) in TABLE.
  8.  
  9. (define (table-walk table proc)
  10.   (let ((table (enforce %table? table)))
  11.     (let* ((vec (%table-vector table))
  12.            (len (%table-next table)))
  13.       (do ((i 0 (fx+ i 2)))
  14.           ((fx>= i len))
  15.         (cond ((vref vec i)
  16.                => (lambda (v)
  17.                     (proc (vref vec (fx+ i 1)) v)))))
  18.       (return))))
  19.  
  20. (define-integrable (walk-table proc table)
  21.     (table-walk table proc))
  22.  
  23. ;;; This returns the first KEY and VALUE for which (PRED KEY VALUE) => true.
  24.  
  25. (define (find-table-entry table pred)
  26.   (let* ((table (enforce %table? table))
  27.          (vec (%table-vector table))
  28.          (len (%table-next table)))
  29.     (iterate loop ((i 0))
  30.       (cond ((fx>= i len)
  31.              (return nil nil))
  32.             ((vref vec i)
  33.              => (lambda (v)
  34.                   (if (pred (vref vec (fx+ i 1)) v)
  35.                       (return (vref vec (fx+ i 1)) v)
  36.                       (loop (fx+ i 2)))))
  37.             (else
  38.              (loop (fx+ i 2)))))))
  39.  
  40. ;;; Copy a table.  This gets its %table from the pool.
  41.  
  42. (define (copy-table table id . copy-proc)
  43.   (let* ((table (enforce %table? table))
  44.          (vec (%table-vector table))
  45.          (len (vector-length vec))
  46.          (copy-proc (if (null? copy-proc) identity (car copy-proc)))
  47.          (new (copy-structure! (obtain-from-pool *table-pool*) table)))
  48.     (let ((new-vec (if (fx= len '2) 
  49.                        empty-vec
  50.                        (obtain-from-pool (table-vector-pool len)))))
  51.       (set (%table-id     new) id)
  52.       (set (%table-vector new) new-vec)
  53.       (cond ((eq? copy-proc identity)
  54.              (vector-replace new-vec vec (vector-length vec)))
  55.             (else
  56.              (iterate loop ((i 0))
  57.                (cond ((fx>= i len) nil)
  58.                      ((vref vec i)
  59.                       => (lambda (v)
  60.                            (set (vref new-vec i) (copy-proc v))
  61.                            (set (vref new-vec (fx+ 1 i)) (vref vec (fx+ i 1)))
  62.                            (loop (fx+ i 2))))
  63.                      (else
  64.                       (set (vref new-vec i) nil)
  65.                       (set (vref new-vec (fx+ i 1)) (vref vec (fx+ i 1)))
  66.                       (loop (fx+ i 2)))))))
  67.       new)))
  68.  
  69. ;;; This stuff is used by the post-gc-hook for weak tables.
  70.  
  71. ;;; Same as CLEAN-AND-SHRINK-TABLE except the vector is not reused
  72.  
  73. (define (clean-and-shrink-table table update)
  74.   (really-clean-and-shrink-table table update t))
  75.  
  76. (define (post-gc-clean-and-shrink-table table update)
  77.   (really-clean-and-shrink-table table update nil))
  78.  
  79. (define (really-clean-and-shrink-table table update recycle?)
  80.   (let* ((table (enforce %table? table))
  81.          (new-count (clean-table-vector! (%table-vector table) update)))
  82.     (set (%table-count table) new-count)
  83.     (if recycle?
  84.         (table-rehash table new-count)
  85.         (really-table-rehash table new-count))
  86.     table))
  87.  
  88. (define (clean-table-vector! vec update)
  89.   (let ((len (vector-length vec)))
  90.     (iterate loop ((i 0) (count 0))
  91.       (cond ((fx>= i len)
  92.              count)
  93.             (else
  94.              (let ((v (vref vec i)))
  95.                (receive (k v)
  96.                         (if (not v)
  97.                             (return nil nil)
  98.                             (receive (k v)
  99.                                      (update (vref vec (fx+ i 1)) v)
  100.                               (if v (return k v) (return nil nil))))
  101.                  (set (vref vec i) v)
  102.                  (set (vref vec (fx+ i 1)) k)
  103.                  (loop (fx+ i 2) (if v (fx+ 1 count) count)))))))))
  104.  
  105.  
  106.  
  107.  
  108.